home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / custom-rt.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  9.2 KB  |  291 lines
  1. ;;; custom-rt.scm: Partial customization support for runtime input
  2. ;;;                processes
  3. ;;;
  4. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  5. ;;;
  6. ;;; All rights reserved.
  7. ;;;
  8. ;;; Redistribution and use in source and binary forms, with or without
  9. ;;; modification, are permitted provided that the following conditions
  10. ;;; are met:
  11. ;;; 1. Redistributions of source code must retain the above copyright
  12. ;;;    notice, this list of conditions and the following disclaimer.
  13. ;;; 2. Redistributions in binary form must reproduce the above copyright
  14. ;;;    notice, this list of conditions and the following disclaimer in the
  15. ;;;    documentation and/or other materials provided with the distribution.
  16. ;;; 3. Neither the name of authors nor the names of its contributors
  17. ;;;    may be used to endorse or promote products derived from this software
  18. ;;;    without specific prior written permission.
  19. ;;;
  20. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  21. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  22. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  23. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  24. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  25. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  26. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  27. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  28. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  29. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  30. ;;; SUCH DAMAGE.
  31. ;;;;
  32.  
  33. ;; This file provides partial custom definition support for runtime
  34. ;; input processes. The processes that wants full-featured custom API
  35. ;; such as uim-pref must overrides these definitions by loading
  36. ;; custom.scm.
  37. ;;
  38. ;; The name 'custom-rt' is not the best to represent this partial
  39. ;; functionality. Give me better name.  -- YamaKen 2005-01-14
  40.  
  41. ;; TODO: write test-custom-rt.scm
  42.  
  43. (require-extension (srfi 6 34))
  44.  
  45. (require "util.scm")
  46. (require "key.scm")
  47.  
  48. (define custom-full-featured? #f)
  49. ;; experimental
  50. (define custom-enable-mtime-aware-user-conf-reloading? #f)
  51.  
  52. (define-record 'custom-choice-rec
  53.   '((sym   #f)
  54.     (label "")
  55.     (desc  "")))
  56.  
  57. (define custom-required-custom-files ())
  58. (define custom-rt-primary-groups ())
  59. (define custom-set-hooks ())
  60. ;; experimental
  61. (define custom-group-conf-freshnesses ())  ;; (gsym . mtime)
  62.  
  63. (define custom-file-path
  64.   (lambda (gsym)
  65.     (let* ((group-name (symbol->string gsym))
  66.        (path (string-append (or (home-directory (user-name)) "")
  67.                 "/.uim.d/customs/custom-"
  68.                 group-name
  69.                 ".scm")))
  70.       path)))
  71.  
  72. ;; experimental
  73. (define custom-update-group-conf-freshness
  74.   (lambda (gsym)
  75.     (let ((mtime (guard (err
  76.              (else #f))
  77.            (file-mtime (custom-file-path gsym)))))
  78.       (set! custom-group-conf-freshnesses
  79.         (alist-replace (cons gsym mtime)
  80.                custom-group-conf-freshnesses))
  81.       #t)))
  82.  
  83. ;; experimental
  84. (define custom-group-conf-updated?
  85.   (lambda (gsym)
  86.     (let ((prev-mtime (assq-cdr gsym custom-group-conf-freshnesses)))
  87.       (or (not prev-mtime)
  88.       (guard (err
  89.           (else #f))
  90.         (not (= (file-mtime (custom-file-path gsym))
  91.             prev-mtime)))))))
  92.  
  93. ;; experimental
  94. (define custom-load-updated-group-conf
  95.   (lambda (gsym)
  96.     (or (not (custom-group-conf-updated? gsym))
  97.     (and (try-load (custom-file-path gsym))
  98.          (custom-update-group-conf-freshness gsym)))))
  99.  
  100. ;; full implementation
  101. ;; This proc is existing for DUMB loading. No more processing such as
  102. ;; mtime comparation or history recording must not be added. Please
  103. ;; keep in mind responsibility separation, and don't alter an API
  104. ;; specification previously stabilized, without discussion.
  105. ;;   -- YamaKen 2005-08-09
  106. (define custom-load-group-conf
  107.   (lambda (gsym)
  108.     (try-load (custom-file-path gsym))))
  109.  
  110. ;; TODO: disable all newly defined customs when an error occurred in loading
  111. ;; full implementation
  112. (define require-custom
  113.   (lambda (filename)
  114.     (let ((pre-groups (custom-list-primary-groups)))
  115.       (require filename)
  116.       (if (not (member filename custom-required-custom-files))
  117.       (set! custom-required-custom-files
  118.         (cons filename custom-required-custom-files)))
  119.       (let* ((post-groups (custom-list-primary-groups))
  120.          (new-groups (list-tail post-groups (length pre-groups))))
  121.     (if (and (not (getenv "LIBUIM_VANILLA"))
  122.          (not (setugid?)))
  123.         (for-each (lambda (gsym)
  124.             (custom-load-group-conf gsym)
  125.             (if custom-enable-mtime-aware-user-conf-reloading?
  126.                 (custom-update-group-conf-freshness gsym)))
  127.               (reverse new-groups)))))))
  128.  
  129. ;; full implementation
  130. (define custom-reload-customs
  131.   (lambda ()
  132.     (for-each load (reverse custom-required-custom-files))
  133.     (custom-call-all-hook-procs custom-set-hooks)))
  134.  
  135. ;; full implementation
  136. (define custom-modify-key-predicate-names
  137.   (lambda (keys)
  138.     (map (lambda (key)
  139.        (if (symbol? key)
  140.            (symbol-append key '?)
  141.            key))
  142.      keys)))
  143.  
  144. ;; lightweight implementation
  145. (define custom-choice-range-reflect-olist-val
  146.   (lambda (dst-sym src-sym indication-alist)
  147.     #f))
  148.  
  149. ;; full implementation
  150. (define custom-rt-add-primary-groups
  151.   (lambda (gsym)
  152.     (if (not (member gsym custom-rt-primary-groups))
  153.     (set! custom-rt-primary-groups
  154.           (cons gsym custom-rt-primary-groups)))))
  155.  
  156. ;; lightweight implementation
  157. (define custom-list-primary-groups
  158.   (lambda ()
  159.     (reverse custom-rt-primary-groups)))
  160.  
  161. ;; TODO: write test
  162. ;; lightweight implementation
  163. (define custom-add-hook
  164.   (lambda (custom-sym hook-sym proc)
  165.     (if (eq? hook-sym
  166.          'custom-set-hooks)
  167.     (set! custom-set-hooks
  168.           (alist-replace (cons custom-sym proc)
  169.                  custom-set-hooks)))))
  170.  
  171. ;; TODO: write test
  172. ;; lightweight implementation
  173. (define custom-call-hook-procs
  174.   (lambda (sym hook)
  175.     (let ((proc (assq sym hook)))
  176.       (if proc
  177.       ((cdr proc))))))
  178.  
  179. ;; TODO: write test
  180. ;; full implementation
  181. (define custom-call-all-hook-procs
  182.   (lambda (hook)
  183.     (for-each (lambda (pair)
  184.         ((cdr pair)))
  185.           hook)))
  186.  
  187. ;; lightweight implementation
  188. (define define-custom-group
  189.   (lambda (gsym label desc)
  190.     #f))
  191.  
  192. ;; lightweight implementation
  193. (define custom-exist?
  194.   (lambda (sym type)
  195.     (symbol-bound? sym)))
  196.  
  197. ;; lightweight implementation
  198. (define custom-key-exist?
  199.   (lambda (sym)
  200.     (let ((key-sym (symbol-append sym '?)))
  201.       (and (symbol-bound? sym)
  202.        (list? (symbol-value sym))
  203.        (symbol-bound? key-sym)
  204.        (procedure? (symbol-value key-sym))))))
  205.  
  206. ;; lightweight implementation
  207. (define custom-value
  208.   (lambda (sym)
  209.     (symbol-value sym)))
  210.  
  211. ;; TODO: rewrite test
  212. ;; lightweight implementation
  213. (define custom-set-value!
  214.   (lambda (sym val)
  215.     (and (cond
  216.       ((custom-key-exist? sym)
  217.        (set-symbol-value! sym val)
  218.        (let ((key-val (custom-modify-key-predicate-names val)))
  219.          (eval (list 'define (symbol-append sym '?)
  220.              (list 'make-key-predicate (list 'quote key-val)))
  221.            (interaction-environment)))
  222.        #t)
  223.       ((custom-exist? sym #f)
  224.        (set-symbol-value! sym val)
  225.        #t)
  226.       (else
  227.        #f))
  228.      (begin
  229.        (custom-call-hook-procs sym custom-set-hooks)
  230.        #t))))
  231.  
  232. ;; TODO: rewrite test
  233. ;; lightweight implementation
  234. (define define-custom
  235.   (lambda (sym default groups type label desc)
  236.     (custom-rt-add-primary-groups (car groups))
  237.     (if (not (custom-exist? sym type))
  238.     (begin
  239.       (let ((quoted-default (if (or (symbol? default)
  240.                     (list? default))
  241.                     (list 'quote default)
  242.                     default)))
  243.         (eval (list 'define sym quoted-default)
  244.           (interaction-environment))
  245.         (if (custom-key-exist? sym)
  246.         ;; already define-key'ed in ~/.uim
  247.         (custom-call-hook-procs sym custom-set-hooks)
  248.         (begin
  249.           (if (eq? (car type)
  250.                'key)
  251.               (eval (list 'define (symbol-append sym '?) list)
  252.                 (interaction-environment)))
  253.           (custom-set-value! sym default))))))))  ;; to apply hooks
  254.  
  255. ;; warning: no validation is performed by custom-set-value! on custom-rt.scm
  256. (define custom-prop-update-custom-handler
  257.   (let ((READ-ERR (list 'read-err))) ;; unique id
  258.     (lambda (context custom-sym val-str)
  259.       (let* ((val (guard (err
  260.               (else READ-ERR))
  261.             (read (open-input-string val-str))))
  262.          (unquoted-val (or (and (pair? val)
  263.                     (eq? (car val) 'quote)
  264.                     (cadr val))
  265.                    val)))
  266.     (and (not (eq? unquoted-val READ-ERR))
  267.          (custom-set-value! custom-sym unquoted-val))))))
  268.  
  269. ;; custom-reload-user-configs can switch its behavior by
  270. ;; custom-enable-mtime-aware-user-conf-reloading? since the
  271. ;; experimental code breaks the semantics of custom variable
  272. ;; broadcasting.
  273. ;;
  274. ;; For example, an arbitrary uim-enabled process can update a custom
  275. ;; variable by its own code without any helper message passing. In
  276. ;; such case, the previously defined broadcasting behavior overwrites
  277. ;; the variable locally modified even if the corresponding custom file
  278. ;; is not updated.
  279. ;;
  280. ;; To make the latter code default, a discussion is required.
  281. ;;   -- YamaKen 2005-08-09
  282. (define custom-reload-user-configs
  283.   (lambda ()
  284.     (and (not (getenv "LIBUIM_VANILLA"))
  285.      (not (setugid?))
  286.      (let ((load-conf (if custom-enable-mtime-aware-user-conf-reloading?
  287.                   custom-load-updated-group-conf
  288.                   custom-load-group-conf)))  ;; original behavior
  289.        (for-each load-conf (custom-list-primary-groups))
  290.        (custom-call-all-hook-procs custom-set-hooks)))))
  291.